home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Tk-methods.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  4.6 KB  |  137 lines
  1. ;;;;
  2. ;;;; T k - m e t h o d s . s t k    -- redefine Tk commands as methods
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  15. ;;;;    Creation date:  9-Feb-1995 22:49
  16. ;;;; Last file update: 17-Jan-1996 23:26
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19.  
  20. ;;;;  C O M M E N T S   A R E   O U T   O F  D A T E
  21.  
  22. ;;;;    This file is loaded at the first make on a Tk object. Its purpose
  23. ;;;;    consists to define new widgets manipulation methods or functions
  24. ;;;;    functions which will do the same job that the equivalent Tk function
  25. ;;;;    (except that they know how manage STklos instances).
  26. ;;;;    This file is loaded as later as possible to allow image creation of
  27. ;;;;     code containing Tk classes
  28.  
  29. ;;;; Loading of this file is done as soon as Tk::make-tk-name is
  30. ;;;; called (i.e. as soon as a Tk object is created since this function is
  31. ;;;; called for making the Id of a widget). Tk::make-tk-name is defined as
  32. ;;;; an autoload in the Basics.stk file
  33.  
  34. ;;;;    Consequently, this file is loaded only when Tk is completly initialized
  35.  
  36.  
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. ;;;;
  39. ;;;; Utilities
  40. ;;;;
  41. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42.  
  43. ;;
  44. ;; Stuff for generating Tcl variable names
  45. ;;
  46. (define Tk::make-tk-name 
  47.   (let ((counter 0))
  48.     (lambda (parent value)
  49.       (format #f "~A.v~A"
  50.           [if (or (eq? parent *root*) (eq? parent *top-root*))
  51.           "" 
  52.           (widget->string (slot-ref parent 'Id))]
  53.           [if (null? value) 
  54.           (begin (set! counter (+ counter 1)) counter)
  55.           value]))))
  56.  
  57. (define Tk::make-variable
  58.   (let ((counter 0))
  59.     (lambda ()
  60.       (set! counter (+ counter 1))
  61.       (format #f "v_~A" counter))))
  62.  
  63.  
  64. ;;; Tk-write-object is called when a STklos object is passed to a Tk-command.
  65. ;;; By default, we do the same job as write; but if an object is a <Tk-widget>
  66. ;;; we will pass it its Eid. This method does this job.
  67. (define-method Tk-write-object((self <Tk-widget>) port)
  68.   (write (widget-name (slot-ref self 'Eid)) port))
  69.  
  70. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71. ;;;;
  72. ;;;; Tk-commands rewriting as methods or functions
  73. ;;;;
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75.  
  76.  
  77. ;;;; A kind of predicate to determine if an object is a Tk-widget descendant
  78. (define-method tk-widget? ((self <Tk-widget>))  #t)
  79. (define-method tk-widget? ((self <top>))        #f)
  80.  
  81. ;; XX;;;; A general bind
  82. ;; XX(define-method bind l (apply Tk:bind l))
  83.  
  84. ;;;; A general destroy
  85. (define-method destroy ((self <Tk-widget>))
  86.   (let ((Eid (slot-ref self 'Eid)))
  87.     ;; Destroy all the sons of this widget
  88.     (apply destroy (map (lambda (x) (or (Id->instance x) x))
  89.             (winfo 'children Eid)))       
  90.     ;; Suicide
  91.     (Tk:destroy Eid)
  92.     (change-class self <Destroyed-object>)))
  93.  
  94. (define-method destroy (obj)
  95.   ;; Method called when not using objects (e.g. [destroy .b] )
  96.   ;; Destroy all the sons of this widget  
  97.   (for-each destroy (winfo 'children obj))
  98.   ;; Suicide
  99.   (let ((inst (Id->instance obj)))
  100.     (when inst (change-class inst <Destroyed-object>))
  101.     (Tk:destroy obj)))
  102.  
  103. (define-method destroy l          ;; Destroy a list of widgets
  104.   (for-each destroy l))
  105.  
  106. ;;;; A general focus
  107. (define-method focus ()
  108.   (let ((inst (Id->instance (Tk:focus))))
  109.     (or inst (Tk:focus))))
  110.   
  111. (define-method focus l (apply Tk:focus l))
  112.  
  113. ;;;; A general unpack (to avoid [pack 'forget ...] which is ugly
  114. (define (unpack . l)
  115.   (apply pack 'forget l))
  116.  
  117.  
  118. (define-method get-Tk-default-value ((self <Tk-widget>) slot)
  119.   (list-ref ((slot-ref self 'Id) 'configure (make-keyword slot)) 3))
  120.  
  121. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  122. ;;;;
  123. ;;;; define *top-root* (a <toplevel> accessing the root window)
  124. ;;;;
  125. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  126.  
  127. (require "Toplevel")
  128.  
  129. (define *top-root* (if Tk:initialized?
  130.                (let ((top (allocate-instance <Toplevel> '())))
  131.              (slot-set! top 'Id     *root*)
  132.              (slot-set! top 'Eid    *root*)
  133.              (slot-set! top 'parent *root*)
  134.              (set-widget-data! *root* `(:instance ,top))
  135.              top)
  136.                #f))
  137.